home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 050 / madtrb13.arc / RVERSI.PAS < prev    next >
Pascal/Delphi Source File  |  1985-05-26  |  31KB  |  1,126 lines
  1. {$C-}
  2. {$R-}
  3. {$U-}
  4. {$K-}
  5.  
  6. program reversi;
  7.  
  8. {
  9.   Program REVERSI  by M. Quinlan    5/26/84
  10.   based on a program in the book Advanced Pascal Programming Techniques
  11.                                  by Paul A. Sand
  12.  
  13.   Version 1 Release 0 Modification level 0
  14.  
  15.     Program from the book modified for the IBM PC and Turbo Pascal.
  16.  
  17.   Version 1 Release 1 Modification level 0
  18.  
  19.     Use all-points-addressable graphics for the board display (loosly based on
  20.     the section in the book titled "Modifying reversi for Graphics").
  21.  
  22.   Version 1 Release 2 Modification level 0
  23.  
  24.     Use customized characters in medium-resolution graphics mode for the
  25.     board display (much faster than APA graphics).  On the "human" move,
  26.     show him which discs would be flipped.
  27.  
  28.   Version 1 Release 3 Modification level 0
  29.  
  30.     Allow human vs. human and computer vs. computer.
  31.  
  32.   Version 1 Release 4 Modification level 0
  33.  
  34.     Display version on the screen.
  35.     Change board evaluation routine:
  36.       if end of game detected, base evaluation totally on the score
  37.       make the sides more important
  38.       make "poison2" squares less important
  39.  
  40. * Version 1 Release 4 Modification level 1
  41.  
  42.     Make minor changes so the input will work correctly with Turbo Pascal
  43.     Version 3.01a and PC DOS 3.1.
  44.  
  45. ==============================================================================
  46.  
  47.   Possible future enhancements:
  48.  
  49.     Help system on entry to describe rules of game, possible strategy, and
  50.     this implementation (how to make a move, etc.).
  51.  
  52.     Allow human to ask computer for a suggested move.
  53.  
  54.     Allow setup mode where human can put disc of either color an any square.
  55.  
  56.     Allow change of mode or player at any time (i.e. play for a while then let
  57.     the computer take over, etc.).
  58.  
  59.     Better handle arrow keys when human selects move: allow Up, Down, Left, Right
  60.     and have the keys move to the next legal square in that direction.
  61.  
  62.     Improve performance.
  63.  
  64.     Improve the level of play.
  65.  
  66.  }
  67.  
  68. const
  69.   MAXMOVES = 60;
  70.  
  71.   LIGHT = 0;
  72.   DARK  = 1;
  73.   EMPTY = 2;
  74.   BORDER = 3;
  75.  
  76. type
  77.   contents   = LIGHT..BORDER;
  78.   plcolor    = LIGHT..DARK;
  79.   pltype     = (COMPUTERPLAYER, HUMANPLAYER);
  80.   squarenum  = 0..99;
  81.   movelist   = record
  82.                  nmoves: 0..MAXMOVES;
  83.                  move:   array [1..MAXMOVES] of squarenum
  84.                end;
  85.   board      = record
  86.                  sq: array [squarenum] of contents;
  87.                  ndiscs: array [plcolor] of integer;
  88.                  possible: movelist
  89.                end;
  90.   direction  = (NORTH, NORTHEAST, EAST, SOUTHEAST,
  91.                 SOUTH, SOUTHWEST, WEST, NORTHWEST);
  92.  
  93. var
  94.   ch: char;
  95.   delta: array [direction] of integer;
  96.   sqord: array [squarenum] of integer;
  97.   sqchar: array [contents] of char;
  98.   corner, poison1, good1: array [1..4] of squarenum;
  99.   poison2, good2: array [1..4, 1..2] of squarenum;
  100.   edge: array [1..4, 1..4] of squarenum;
  101.  
  102. { GRAPHDRA.PAS }
  103. const
  104.   xbase = 0;
  105.   ybase = 4;
  106.   xscale = 2;
  107.   yscale = 2;
  108.   PIXELSPERCHAR = 8;
  109.  
  110.   bgcolor = 0;
  111.   palcolor = 3;
  112.  
  113.   black = 0;
  114.   lcyan = 1;
  115.   lmagenta = 2;
  116.   white = 3;
  117.  
  118.   SQLIGHT = 0;
  119.   SQDARK  = 1;
  120.   SQEMPTY = 2;
  121.   SQCURSOR = 3;
  122.   SQTOBELIGHT = 4;
  123.   SQTOBEDARK  = 5;
  124.  
  125. type
  126.   color = black..white;
  127.   sqtype = SQLIGHT..SQTOBEDARK;
  128.  
  129. type
  130.   chardefarray = array[0..191] of byte;
  131.  
  132. const
  133.   chardef: chardefarray = ($FF, $80, $80, $9F, $9F, $9F, $9F, $9F,
  134.                            $FF, $01, $01, $F9, $F9, $F9, $F9, $F9,
  135.                            $9F, $9F, $9F, $9F, $9F, $80, $80, $FF,
  136.                            $F9, $F9, $F9, $F9, $F9, $01, $01, $FF,
  137.  
  138.                            $FF, $80, $80, $9F, $9F, $98, $98, $98,
  139.                            $FF, $01, $01, $F9, $F9, $19, $19, $19,
  140.                            $98, $98, $98, $9F, $9F, $80, $80, $FF,
  141.                            $19, $19, $19, $F9, $F9, $01, $01, $FF,
  142.  
  143.                            $FF, $80, $80, $80, $80, $80, $80, $80,
  144.                            $FF, $01, $01, $01, $01, $01, $01, $01,
  145.                            $80, $80, $80, $80, $80, $80, $80, $FF,
  146.                            $01, $01, $01, $01, $01, $01, $01, $FF,
  147.  
  148.                            $FF, $80, $80, $80, $80, $80, $80, $80,
  149.                            $FF, $01, $01, $01, $01, $01, $01, $01,
  150.                            $80, $80, $80, $80, $80, $80, $80, $FF,
  151.                            $01, $01, $01, $01, $01, $01, $01, $FF,
  152.  
  153.                            $FF, $80, $80, $9F, $9F, $98, $98, $98,
  154.                            $FF, $01, $01, $F9, $F9, $19, $19, $19,
  155.                            $98, $98, $98, $9F, $9F, $80, $80, $FF,
  156.                            $19, $19, $19, $F9, $F9, $01, $01, $FF,
  157.  
  158.                            $FF, $80, $80, $9F, $9F, $9F, $9F, $9F,
  159.                            $FF, $01, $01, $F9, $F9, $F9, $F9, $F9,
  160.                            $9F, $9F, $9F, $9F, $9F, $80, $80, $FF,
  161.                            $F9, $F9, $F9, $F9, $F9, $01, $01, $FF);
  162.  
  163. procedure initgraph;
  164.   begin
  165.     GraphColorMode;
  166.     GraphBackground(bgcolor);
  167.     Palette(palcolor);
  168.     Textcolor(lcyan);
  169.     MemW[$0000:$007E] := Seg(chardef);
  170.     MemW[$0000:$007C] := Ofs(chardef);
  171.   end;
  172.  
  173. procedure dispgrid;
  174.   begin { dispgrid }
  175.   end; { dispgrid }
  176.  
  177. procedure buildsquare;
  178.   begin
  179.   end;
  180.  
  181. procedure fillbkgrnd(i, j: integer);
  182.   var
  183.     x, y: integer;
  184.     xpscale, ypscale: integer;
  185.   begin
  186.     xpscale := PIXELSPERCHAR * xscale;
  187.     ypscale := PIXELSPERCHAR * yscale;
  188.     x := ((i * xscale) + xbase) * PIXELSPERCHAR;
  189.     y := ((j * yscale) + ybase) * PIXELSPERCHAR;
  190.     draw(x + 1, y + 1, x + xpscale - 1, y + 1, lmagenta);
  191.     draw(x + 1, y + 2, x + xpscale - 1, y + 2, lmagenta);
  192.     draw(x + 1, y + ypscale - 2, x + xpscale - 1, y + ypscale - 2, lmagenta);
  193.     draw(x + 1, y + ypscale - 3, x + xpscale - 1, y + ypscale - 3, lmagenta);
  194.     draw(x + 1, y + 3, x + 1, y + ypscale - 3, lmagenta);
  195.     draw(x + 2, y + 3, x + 2, y + ypscale - 3, lmagenta);
  196.     draw(x + xpscale - 2, y + 3, x + xpscale - 2, y + ypscale - 3, lmagenta);
  197.     draw(x + xpscale - 3, y + 3, x + xpscale - 3, y + ypscale - 3, lmagenta)
  198.   end;
  199.  
  200. procedure fillsquare(i,j: integer; c: color);
  201.   var
  202.     x, y, xpscale, ypscale, k: integer;
  203.   begin
  204.     xpscale := PIXELSPERCHAR * xscale;
  205.     ypscale := PIXELSPERCHAR * yscale;
  206.     x := ((i * xscale) + xbase) * PIXELSPERCHAR;
  207.     y := ((j * yscale) + ybase) * PIXELSPERCHAR;
  208.     for k := 1 to (ypscale - 2) do
  209.       draw(x + 1, y + k, x + xpscale - 1, y + k, c)
  210.   end;
  211.  
  212. procedure fillcursor(i, j: integer);
  213.   begin
  214.     fillsquare(i, j, lmagenta)
  215.   end;
  216.  
  217. procedure clearsquare(i, j: integer);
  218.   begin
  219.     fillsquare(i, j, black)
  220.   end;
  221.  
  222. procedure drawsquare(k: squarenum; c: sqtype);
  223.  
  224.   var
  225.     i, j, ch: integer;
  226.   begin
  227.     i := k mod 10 - 1;
  228.     j := k div 10 - 1;
  229.     Textcolor(white);
  230.     GotoXY(i*xscale + xbase + 1, j*yscale + ybase + 1);
  231.     ch := (c*4) + $80;
  232.     write(char(ch));
  233.     write(char(ch+1));
  234.     GotoXY(i*xscale + xbase + 1, j*yscale + ybase + 2);
  235.     write(char(ch+2));
  236.     write(char(ch+3));
  237.     if (c = SQTOBEDARK) or (c = SQTOBELIGHT) then
  238.       fillbkgrnd(i, j)
  239.     else if c = SQCURSOR then
  240.       fillcursor(i, j);
  241.     TextColor(lcyan)
  242.   end;
  243.  
  244. { CRTSTUFF.PAS }
  245. type
  246.   crtcommand = (HOME, CLEAR, UP, DOWN, LEFT, RIGHT, BEEP);
  247.   g_string = string[255];
  248.   charset  = set of char;
  249.  
  250. procedure crt(cc: crtcommand);
  251.  
  252. var
  253.   i: integer;
  254.  
  255. begin
  256.   case cc of
  257.     HOME:
  258.       GotoXY(1,1);
  259.     CLEAR:
  260.       initgraph;
  261.     UP:
  262.       if WhereY > 1 then
  263.         GotoXY(WhereX, WhereY - 1);
  264.     DOWN:
  265.       if WhereY < 24 then
  266.         GotoXY(WhereX, WhereY + 1);
  267.     LEFT:
  268.       if WhereX > 1 then
  269.         GotoXY(WhereX - 1, WhereY);
  270.     RIGHT:
  271.       if WhereX < 40 then
  272.         GotoXY(WhereX + 1, WhereY);
  273.     BEEP:
  274.       for i:=1 to 2 do begin
  275.         Sound(220);
  276.         Delay(100);
  277.         NoSound;
  278.         Delay(50)
  279.       end
  280.   end
  281. end;
  282.  
  283. procedure eraseline(row: integer);
  284. begin
  285.   GotoXY(1, row);
  286.   write(' ':40);
  287.   GotoXY(1, row)
  288. end;
  289.  
  290. procedure center(s: g_string; row: integer);
  291. begin
  292.   eraseline(row);
  293.   GotoXY( (40 - length(s) + 1) div 2, row);
  294.   write(s)
  295. end;
  296.  
  297. procedure disptitle(s: g_string);
  298.  
  299. var
  300.   i, nch: integer;
  301.  
  302. begin
  303.   center(s, 1);
  304. end;
  305.  
  306. function getkey(var ch: char; valid: charset; shiftlock: boolean): char;
  307. var
  308.   ok: boolean;
  309. begin
  310.   repeat
  311.     readln(ch);
  312.     if shiftlock then
  313.       ch := UpCase(ch);
  314.     ok := ch in valid;
  315.     if not ok then
  316.       crt(BEEP)
  317.   until ok;
  318.   getkey := ch
  319. end;
  320.  
  321. { INITREV.PAS }
  322. procedure initrev;
  323.   var
  324.     i, j, sv: integer;
  325.  
  326.   begin { initrev }
  327.     sqchar[DARK] := 'B';
  328.     sqchar[LIGHT] := 'W';
  329.     sqchar[EMPTY] := ' ';
  330.     sqchar[BORDER] := '*';
  331.     sqord[11] := 1; sqord[12] := 7; sqord[13] := 2; sqord[14] := 2;
  332.                     sqord[22] := 8; sqord[23] := 6; sqord[24] := 5;
  333.                                     sqord[33] := 3; sqord[34] := 4;
  334.                                                     sqord[44] := 0;
  335.     for j := 1 to 4 do
  336.       for i := j to 4 do
  337.         begin
  338.           sv := sqord[10 * j + i];
  339.           sqord[10 * i + j] := sv;
  340.           sqord[10 * (9 - i) + j] := sv;
  341.           sqord[10 * (9 - j) + i] := sv;
  342.           sqord[10 * j + 9 - i] := sv;
  343.           sqord[10 * i + 9 - j] := sv;
  344.           sqord[10 * (9 - i) + 9 - j] := sv;
  345.           sqord[10 * (9 - j) + 9 - i] := sv
  346.         end;
  347.     delta[NORTH] := -10;
  348.     delta[NORTHEAST] := -9;
  349.     delta[EAST] := 1;
  350.     delta[SOUTHEAST] := 11;
  351.     delta[SOUTH] := 10;
  352.     delta[SOUTHWEST] := 9;
  353.     delta[WEST] := -1;
  354.     delta[NORTHWEST] := -11;
  355.  
  356.     corner[1]     := 11; poison2[1, 1] := 12; good2[1, 1] := 13;
  357.     poison2[1, 2] := 21; poison1[1]    := 22;
  358.     good2[1, 2]   := 31;                      good1[1]    := 33;
  359.  
  360.     corner[2]     := 18; poison2[2, 1] := 17; good2[2, 1] := 16;
  361.     poison2[2, 2] := 28; poison1[2]    := 27;
  362.     good2[2, 2]   := 38;                      good1[2]    := 36;
  363.  
  364.     corner[3]     := 81; poison2[3, 1] := 82; good2[3, 1] := 83;
  365.     poison2[3, 2] := 71; poison1[3]    := 72;
  366.     good2[3, 2]   := 61;                      good1[3]    := 63;
  367.  
  368.     corner[4]     := 88; poison2[4, 1] := 87; good2[4, 1] := 86;
  369.     poison2[4, 2] := 78; poison1[4]    := 77;
  370.     good2[4, 2]   := 68;                      good1[4]    := 66;
  371.  
  372.     for i := 1 to 4 do
  373.       begin
  374.         edge[1, i] := 12 + i;
  375.         edge[2, i] := 28 + 10 * i;
  376.         edge[3, i] := 21 + 10 * i;
  377.         edge[4, i] := 82 + i
  378.       end
  379.   end; { initrev }
  380.  
  381. { DISPSQUA.PAS }
  382. procedure dispsquare(k: squarenum; c: contents);
  383.   begin { dispsquare }
  384.     case c of
  385.       LIGHT: drawsquare(k, sqlight);
  386.       DARK : drawsquare(k, sqdark);
  387.       EMPTY: drawsquare(k, sqempty);
  388.       BORDER: drawsquare(k, sqcursor)
  389.     end
  390.   end; { dispsquare }
  391.  
  392. { ITOS.PAS }
  393. procedure itos(n, wid: integer; var s: g_string);
  394.   var
  395.     negnum: boolean;
  396.  
  397.   begin { debugproc('itos'); }
  398.     negnum := (n < 0);
  399.     n := abs(n);
  400.     s := '';
  401.     repeat
  402.       s := chr(n mod 10 + 48) + s;
  403.       n := n div 10
  404.     until n = 0;
  405.     if negnum then
  406.       s := '-' + s;
  407.     while length(s) < wid do
  408.       s := ' ' + s;
  409.   end; { itos }
  410.  
  411. { FLANKING.PAS }
  412. function flanking(k: squarenum; dir: direction; var bd: board; pl: plcolor):
  413.          boolean;
  414.   var
  415.     ok: boolean;
  416.     opponent: plcolor;
  417.     del: integer;
  418.   begin { flanking }
  419.     ok := FALSE;
  420.     opponent := 1-pl;
  421.     del := delta[dir];
  422.     k := k + del;
  423.     with bd do
  424.       if sq[k] = opponent then
  425.         begin
  426.           repeat
  427.             k := k + del
  428.           until sq[k] <> opponent;
  429.           ok := (sq[k] = pl)
  430.         end;
  431.     flanking := ok
  432.   end; { flanking }
  433.  
  434. { LEGALMOV.PAS }
  435. function legalmove(k: squarenum; var bd: board; pl: plcolor): boolean;
  436.   var
  437.     ok: boolean;
  438.     dir: direction;
  439.   begin { legalmove }
  440.     dir := NORTH;
  441.     ok := flanking(k, dir, bd, pl);
  442.     while (dir <> NORTHWEST) and not ok do
  443.       begin
  444.         dir := succ(dir);
  445.         ok := flanking(k, dir, bd, pl)
  446.       end;
  447.     legalmove := ok
  448.   end; { legalmove}
  449.  
  450. { MAKELIST.PAS }
  451. function makelist(var legal: movelist; pl: plcolor; var bd: board): integer;
  452.   var
  453.     i: integer;
  454.  
  455.   begin { makelist }
  456.     legal.nmoves := 0;
  457.     with bd.possible do
  458.       for i := 1 to nmoves do
  459.         if legalmove(move[i], bd, pl) then
  460.           begin
  461.             legal.nmoves := legal.nmoves + 1;
  462.             legal.move[legal.nmoves] := move[i]
  463.           end;
  464.     makelist := legal.nmoves
  465.   end; { makelist }
  466.  
  467. { DELMOVE.PAS }
  468. procedure delmove(k: squarenum; var list: movelist);
  469.   var
  470.     i: integer;
  471.   begin { debugproc('delmove'); }
  472.     with list do
  473.       begin
  474.         move[nmoves + 1] := k;
  475.         i := 1;
  476.         while move[i] <> k do i := i + 1;
  477.         if i < nmoves + 1 then
  478.           begin
  479.             while i <= nmoves - 1 do
  480.               begin
  481.                 move [i] := move[i + 1];
  482.                 i := i + 1
  483.               end;
  484.             nmoves := nmoves - 1
  485.           end
  486.       end
  487.   end; { delmove }
  488.  
  489. { ADDMOVE.PAS }
  490. procedure addmove(k: squarenum; var list: movelist);
  491.   var
  492.     i: integer;
  493.   begin { debugproc('addmove'); }
  494.     with list do
  495.       begin
  496.         move[nmoves + 1] := k;
  497.         i := 1;
  498.         while move[i] <> k do
  499.           i := i + 1;
  500.         if i = nmoves + 1 then
  501.           nmoves := nmoves + 1
  502.       end
  503.   end; { addmove }
  504.  
  505. procedure playgame;
  506.   var
  507.     mainboard: board;
  508.     list: movelist;
  509.     gameover, moved: boolean;
  510.     currentplayer: plcolor;
  511.     playertype: array [plcolor] of pltype;
  512.     lookahead: integer;
  513.     k: squarenum;
  514.  
  515. { SETSQUAR.PAS }
  516. procedure setsquare(k: squarenum; c: contents);
  517.   begin { debugproc('setsquare'); }
  518.     mainboard.sq[k] := c;
  519.     dispsquare(k, c)
  520.   end; { setsquare }
  521.  
  522. { DISPSCOR.PAS }
  523. procedure dispscore;
  524.   var
  525.     s: string[255];
  526.  
  527.   begin { dispscore }
  528.     with mainboard do
  529.       begin
  530.         itos(ndiscs[LIGHT], 2, s);
  531.         GotoXY(37,6);
  532.         write(s);
  533.         itos(ndiscs[DARK], 2, s);
  534.         GotoXY(37,7);
  535.         write(s)
  536.       end
  537.   end; { dispscore }
  538.  
  539. { INITGAME.PAS }
  540. procedure initgame;
  541.   var
  542.     i, j: integer;
  543.     ch: char;
  544.  
  545.   begin { initgame }
  546.     with mainboard do
  547.       begin
  548.         for i := 0 to 9 do
  549.           begin
  550.             sq[i] := BORDER;
  551.             sq[i + 90] := BORDER;
  552.             sq[10 * i] := BORDER;
  553.             sq[10 * i + 9] := BORDER
  554.           end;
  555.         ndiscs[LIGHT] := 2;
  556.         ndiscs[DARK]  := 2;
  557.         with possible do
  558.           begin
  559.             nmoves := 12;
  560.             move[ 1] := 33;
  561.             move[ 2] := 34;
  562.             move[ 3] := 35;
  563.             move[ 4] := 36;
  564.             move[ 5] := 43;
  565.             move[ 6] := 46;
  566.             move[ 7] := 53;
  567.             move[ 8] := 56;
  568.             move[ 9] := 63;
  569.             move[10] := 64;
  570.             move[11] := 65;
  571.             move[12] := 66
  572.           end
  573.       end;
  574.     for i := 1 to 8 do
  575.       for j := 1 to 8 do
  576.         setsquare(10 * i + j, EMPTY);
  577.     setsquare(44, LIGHT);
  578.     setsquare(55, LIGHT);
  579.     setsquare(45, DARK);
  580.     setsquare(54, DARK);
  581.     for i := 5 to 9 do begin
  582.       GotoXY(21, i);
  583.       write(' ':20)
  584.     end;
  585.     eraseline(23);
  586.     eraseline(24);
  587.     GotoXY(1,23);
  588.     write('Player types: C = computer, H = Human');
  589.     GotoXY(1,24);
  590.     write('White player (C/H): ');
  591.     case getkey(ch, ['C', 'H'], TRUE) of
  592.       'C': playertype[LIGHT] := COMPUTERPLAYER;
  593.       'H': playertype[LIGHT] := HUMANPLAYER;
  594.     end;
  595.     eraseline(24);
  596.     GotoXY(1,24);
  597.     write('Black player (C/H): ');
  598.     case getkey(ch, ['C', 'H'], TRUE) of
  599.       'C': playertype[DARK] := COMPUTERPLAYER;
  600.       'H': playertype[DARK] := HUMANPLAYER;
  601.     end;
  602.     eraseline(23);
  603.     eraseline(24);
  604.     if (playertype[LIGHT] = COMPUTERPLAYER) or (playertype[DARK] = COMPUTERPLAYER) then
  605.     begin
  606.       GotoXY(1,24);
  607.       write('Enter lookahead for computer (1-6): ');
  608.       lookahead := ord(getkey(ch, ['1'..'6'], FALSE)) - 48;
  609.       GotoXY(28,8);
  610.       write('Lookahead:');
  611.       write(ch)
  612.     end;
  613.     eraseline(24);
  614.     GotoXY(31,6);
  615.     write('White:');
  616.     GotoXY(31,7);
  617.     write('Black:');
  618.   end; { initgame }
  619.  
  620.     function getcomputer(var list: movelist): squarenum;
  621.       var
  622.         max: integer;
  623.         best: squarenum;
  624.  
  625. { EVAL.PAS }
  626.       function eval(var bd: board; pl: plcolor; ourpl: plcolor): integer;
  627.         const
  628.           K1 = 1;      { weighting factor for disc advantage }
  629.           K2 = 3;      { weighting factor for mobility }
  630.           K3 = 200;    { score for owning corner }
  631.           K4 = -100;   { penalty for owning poison1 square }
  632.           K5 = 50;     { score for owning good1 square }
  633.           K6 = -15;    { penalty for owning poison2 square }
  634.           K7 = 15;     { score for owning good2 square }
  635.           K8 = 20;     { score for having ownly discs on edge }
  636.           K9 = 30;     { score for occupying edge }
  637.  
  638.         var
  639.           list: movelist;
  640.           i, j, score: integer;
  641.           c: contents;
  642.           sideset: set of contents;
  643.           opp: plcolor;
  644.           plmoves: integer;
  645.  
  646.        function endgame: boolean;
  647.        begin
  648.          endgame := FALSE;
  649.          if plmoves = 0 then
  650.          begin
  651.            if makelist(list, 1-pl, bd) = 0 then
  652.              endgame := TRUE
  653.          end
  654.        end;
  655.  
  656.         begin { eval }
  657.           opp := 1 - ourpl;
  658.           with bd do begin
  659.             score := K1 * (ndiscs[ourpl] - ndiscs[opp]);
  660.             plmoves := makelist(list, pl, bd);
  661.             if endgame then
  662.             begin
  663.               if score > 0 then
  664.                 eval := maxint
  665.               else if score < 0 then
  666.                 eval := -maxint
  667.               else
  668.                 eval := 0
  669.             end
  670.             else begin
  671.               if pl = ourpl then
  672.                 score := score + k2 * plmoves
  673.               else
  674.                 score := score - K2 * plmoves;
  675.               for i := 1 to 4 do begin
  676.                 c := sq[corner[i]];
  677.                 if c = ourpl then
  678.                   score := score + K3
  679.                 else if c = opp then
  680.                   score := score - K3
  681.                 else begin { corner empty, check poison squares }
  682.                   c := sq[poison1[i]];
  683.                   if c = ourpl then
  684.                     score := score + K4
  685.                   else if c = opp then
  686.                     score := score - K4
  687.                   else begin
  688.                     c := sq[good1[i]];
  689.                     if c = ourpl then
  690.                       score := score + K5
  691.                     else if c = opp then
  692.                       score := score - K5
  693.                   end;
  694.                   for j := 1 to 2 do begin
  695.                     c := sq[poison2[i, j]];
  696.                     if c = ourpl then
  697.                       score := score + K6
  698.                     else if c = opp then
  699.                       score := score - K6
  700.                     else begin
  701.                       c := sq[good2[i, j]];
  702.                       if c = ourpl then
  703.                         score := score + k7
  704.                       else if c = opp then
  705.                         score := score - K7
  706.                     end
  707.                   end
  708.                 end
  709.               end;
  710.               for i := 1 to 4 do begin
  711.                 sideset := [];
  712.                 for j := 1 to 4 do
  713.                   sideset := sideset + [sq[edge[i, j]]];
  714.                 if sideset = [ourpl] then
  715.                   score := score + K9
  716.                 else if sideset = [ourpl, EMPTY] then
  717.                   score := score + K8
  718.                 else if sideset = [opp, EMPTY] then
  719.                   score := score - K8
  720.                 else if sideset = [opp] then
  721.                   score := score - K9
  722.               end;
  723.               eval := score
  724.             end
  725.           end
  726.         end; { eval }
  727.  
  728. { TRYMOVE.PAS }
  729.       procedure trymove(trysq: squarenum; pl: plcolor; var bd: board);
  730.         var
  731.           dir: direction;
  732.           k1: squarenum;
  733.           opp: plcolor;
  734.           del: integer;
  735.         begin { trymove }
  736.           opp := 1 - pl;
  737.           with bd do begin
  738.             sq[trysq] := pl;
  739.             ndiscs[pl] := ndiscs[pl] + 1;
  740.             delmove(trysq, possible);
  741.             for dir := NORTH to NORTHWEST do begin
  742.               del := delta[dir];
  743.               if flanking(trysq, dir, bd, pl) then begin
  744.                 k1 := trysq + del;
  745.                 repeat
  746.                   sq[k1] := pl;
  747.                   ndiscs[pl] := ndiscs[pl] + 1;
  748.                   ndiscs[opp] := ndiscs[opp] - 1;
  749.                   k1 := k1 + del
  750.                 until sq[k1] = pl
  751.               end
  752.               else if sq[trysq + del] = EMPTY then
  753.                 addmove(trysq + del, possible)
  754.             end
  755.           end
  756.         end; { trymove }
  757.  
  758. { SORTLIST.PAS }
  759.       procedure sortlist(var list: movelist);
  760.         var
  761.           i, j, jg, gap, k: integer;
  762.         begin { sortlist }
  763.           with list do begin
  764.             gap := nmoves div 2;
  765.             while gap > 0 do begin
  766.               for i := gap + 1 to nmoves do begin
  767.                 j := i - gap;
  768.                 while j > 0 do begin
  769.                   jg := j + gap;
  770.                   if sqord[move[j]] <= sqord[move[jg]] then
  771.                     j := 0
  772.                   else begin
  773.                     k := move[j];
  774.                     move[j] := move[jg];
  775.                     move[jg] := k
  776.                   end;
  777.                   j := j - gap
  778.                 end
  779.               end;
  780.               gap := gap div 2
  781.             end
  782.           end
  783.         end; { sortlist }
  784.  
  785. { FINDMAX.PAS }
  786.       function findmin(look: integer; var list: movelist; var bd: board;
  787.         cutoff: integer; var bestmove: squarenum; ourpl: plcolor): integer;
  788.         forward;
  789.  
  790.       function findmax(look: integer; var list: movelist; var bd: board;
  791.         cutoff: integer; var bestmove: squarenum; ourpl: plcolor): integer;
  792.         var
  793.           newlist: movelist;
  794.           newbd: board;
  795.           i, maxscore, score, nm: integer;
  796.           junk: squarenum;
  797.           opp: plcolor;
  798.  
  799.         begin { findmax }
  800.           opp := 1 - ourpl;
  801.           sortlist(list);
  802.           with list do
  803.             if nmoves > 0 then begin
  804.               maxscore := -MAXINT;
  805.               i := 1;
  806.               repeat
  807.                 newbd := bd;
  808.                 trymove(move[i], ourpl, newbd);
  809.                 if look <= 1 then
  810.                   score := eval(newbd, opp, ourpl)
  811.                 else begin
  812.                   nm := makelist(newlist, opp, newbd);
  813.                   score := findmin(look - 1, newlist, newbd, maxscore, junk, ourpl)
  814.                 end;
  815.                 if score > maxscore then begin
  816.                   maxscore := score;
  817.                   bestmove := move[i]
  818.                 end;
  819.                 i := i + 1
  820.               until (i > nmoves) or (maxscore >= cutoff)
  821.             end
  822.             else begin { no legal move }
  823.               if look <= 1 then
  824.                 maxscore := eval(bd, opp, ourpl)
  825.               else begin
  826.                 nm := makelist(newlist, opp, bd);
  827.                 maxscore := findmin(look - 1, newlist, bd, -MAXINT, junk, ourpl)
  828.               end
  829.             end;
  830.           findmax := maxscore
  831.         end; { findmax }
  832.  
  833. { FINDMIN.PAS }
  834.       function findmin;
  835.         var
  836.           newlist: movelist;
  837.           newbd: board;
  838.           i, minscore, score, nm: integer;
  839.           junk: squarenum;
  840.           opp: plcolor;
  841.  
  842.         begin { findmin }
  843.           opp := 1 - ourpl;
  844.           sortlist(list);
  845.           with list do
  846.             if nmoves > 0 then begin
  847.               minscore := MAXINT;
  848.               i := 1;
  849.               repeat
  850.                 newbd := bd;
  851.                 trymove(move[i], opp, newbd);
  852.                 if look <= 1 then
  853.                   score := eval(newbd, ourpl, ourpl)
  854.                 else begin
  855.                   nm := makelist(newlist, ourpl, newbd);
  856.                   score := findmax(look - 1, newlist, newbd, minscore, junk, ourpl)
  857.                 end;
  858.                 if score < minscore then begin
  859.                   minscore := score;
  860.                   bestmove := move[i]
  861.                 end;
  862.                 i := i + 1
  863.               until (i > nmoves) or (minscore <= cutoff)
  864.             end
  865.             else begin { no legal move }
  866.               if look <= 1 then
  867.                 minscore := eval(bd, ourpl, ourpl)
  868.               else begin
  869.                 nm := makelist(newlist, ourpl, bd);
  870.                 minscore := findmax(look - 1, newlist, bd, MAXINT, junk, ourpl)
  871.               end
  872.             end;
  873.           findmin := minscore
  874.         end; { findmin }
  875.  
  876.       begin { getcomputer }
  877.         if list.nmoves = 1 then { only 1 legal move }
  878.           getcomputer := list.move[1]
  879.         else begin
  880.           max := findmax(lookahead, list, mainboard, MAXINT, best, currentplayer);
  881.           getcomputer := best
  882.         end
  883.       end; { getcomputer }
  884.  
  885. { GETHUMAN.PAS }
  886. procedure makeflip(var fl: movelist; cp: plcolor; mv: squarenum; var bd: board);
  887.   var
  888.     dir: direction;
  889.     k1: squarenum;
  890.     del: integer;
  891.     i: integer;
  892.   begin
  893.     fl.nmoves := 0;
  894.     bd.sq[mv] := cp;
  895.     for dir := NORTH to NORTHWEST do
  896.       begin
  897.         del := delta[dir];
  898.         if flanking(mv, dir, bd, cp) then
  899.           begin
  900.             k1 := mv + del;
  901.             repeat
  902.               fl.nmoves := fl.nmoves + 1;
  903.               fl.move[fl.nmoves] := k1;
  904.               k1 := k1 + del
  905.             until bd.sq[k1] = cp
  906.           end
  907.       end;
  908.     bd.sq[mv] := EMPTY
  909.   end;
  910.  
  911. function gethuman(var list: movelist): squarenum;
  912.   type
  913.     movekey = (ACCEPT, NEXTMOVE, PREVMOVE);
  914.   var
  915.     i, j: integer;
  916.     ch: char;
  917.     m: movekey;
  918.     fliplist: movelist;
  919.     sq: integer;
  920.  
  921.   function getmovekey: movekey;
  922.     var
  923.       ch: char;
  924.       gotkey: boolean;
  925.  
  926.     begin { getmovekey }
  927.       gotkey := FALSE;
  928.       while not gotkey do
  929.         begin
  930.           read(kbd, ch);
  931.           if ch = char(27) then
  932.             begin
  933.               read(kbd, ch);
  934.               if ch = 'K' then  { left arrow }
  935.                 begin
  936.                   gotkey := TRUE;
  937.                   getmovekey := PREVMOVE
  938.                 end
  939.               else if ch = 'M' then { right arrow }
  940.                 begin
  941.                   gotkey := TRUE;
  942.                   getmovekey := NEXTMOVE
  943.                 end
  944.               else
  945.                 crt(BEEP);
  946.             end
  947.           else { ch <> char(27) }
  948.             if ch = char(13) then
  949.               begin
  950.                 gotkey := TRUE;
  951.                 getmovekey := ACCEPT
  952.               end
  953.             else
  954.               crt(BEEP);
  955.         end { while not gotkey }
  956.     end; { getmovekey }
  957.  
  958.   begin { gethuman }
  959.     i := 1;
  960.     crt(BEEP);
  961.     with list do
  962.       begin
  963.         repeat
  964.           dispsquare(move[i], BORDER);
  965.           if currentplayer = dark then
  966.             sq := SQTOBEDARK
  967.           else
  968.             sq := SQTOBELIGHT;
  969.           makeflip(fliplist, currentplayer, move[i], mainboard);
  970.           for j := 1 to fliplist.nmoves do
  971.             drawsquare(fliplist.move[j], sq);
  972.           m := getmovekey;
  973.           for j := fliplist.nmoves downto 1 do
  974.             drawsquare(fliplist.move[j], 1-currentplayer);
  975.           dispsquare(move[i], EMPTY);
  976.           case m of
  977.             PREVMOVE:
  978.               begin
  979.                 i := i - 1;
  980.                 if i < 1 then i := nmoves
  981.               end;
  982.             NEXTMOVE:
  983.               begin
  984.                 i := i + 1;
  985.                 if i > nmoves then i := 1
  986.               end
  987.             end
  988.         until m = ACCEPT;
  989.         gethuman := move[i]
  990.       end
  991.   end; { gethuman }
  992.  
  993. { GETMOVE.PAS }
  994. function getmove(var list: movelist; pl: pltype): squarenum;
  995.  
  996.   begin { getmove }
  997.     Textcolor(lmagenta);
  998.     if currentplayer = LIGHT then
  999.       begin
  1000.         GotoXY(31,6);
  1001.         write('White:')
  1002.       end
  1003.     else
  1004.       begin
  1005.         GotoXY(31,7);
  1006.         write('Black:')
  1007.       end;
  1008.     Textcolor(lcyan);
  1009.     if pl = COMPUTERPLAYER then
  1010.       getmove := getcomputer(list)
  1011.     else
  1012.       getmove := gethuman(list);
  1013.     if currentplayer = LIGHT then
  1014.       begin
  1015.         GotoXY(31,6);
  1016.         write('White:')
  1017.       end
  1018.     else
  1019.       begin
  1020.         GotoXY(31,7);
  1021.         write('Black:')
  1022.       end
  1023.   end; { getmove }
  1024.  
  1025. { MAKEMOVE.PAS }
  1026. procedure makemove(k: squarenum; pl: plcolor);
  1027.   var
  1028.     dir: direction;
  1029.     k1: squarenum;
  1030.     opponent: plcolor;
  1031.     del: integer;
  1032.  
  1033.   begin { makemove }
  1034.     setsquare(k, pl);
  1035.     opponent := 1 - pl;
  1036.     with mainboard do
  1037.       begin
  1038.         ndiscs[pl] := ndiscs[pl] + 1;
  1039.         delmove(k, possible);
  1040.         for dir := NORTH to NORTHWEST do
  1041.           begin
  1042.             del := delta[dir];
  1043.             if flanking(k, dir, mainboard, pl) then
  1044.               begin
  1045.                 k1 := k + del;
  1046.                 repeat
  1047.                   setsquare(k1, pl);
  1048.                   ndiscs[pl] := ndiscs[pl] + 1;
  1049.                   ndiscs[opponent] := ndiscs[opponent] - 1;
  1050.                   k1 := k1 + del
  1051.                 until sq[k1] = pl
  1052.               end
  1053.             else if sq[k + del] = EMPTY then
  1054.               addmove(k + del, possible)
  1055.           end
  1056.       end
  1057.   end; { makemove }
  1058.  
  1059. { DECLWINN.PAS }
  1060.  
  1061. procedure declarewinner;
  1062.   var
  1063.     diff: integer;
  1064.     s: string[255];
  1065.   begin { declarewinner }
  1066.     with mainboard do
  1067.       diff := ndiscs[LIGHT] - ndiscs[DARK];
  1068.     if diff > 0 then
  1069.       begin
  1070.         itos(diff, 0, s);
  1071.         GotoXY(25,9);
  1072.         write('White won by ' + s)
  1073.       end
  1074.     else if diff < 0 then
  1075.       begin
  1076.         itos(-diff, 0, s);
  1077.         GotoXY(25,9);
  1078.         write('Black won by ' + s)
  1079.       end
  1080.     else begin
  1081.       GotoXY(27,9);
  1082.       write('Game is tied!')
  1083.     end
  1084.   end; { declarewinner }
  1085.  
  1086.   begin { playgame }
  1087.     initgame;
  1088.     currentplayer := DARK;
  1089.     gameover := FALSE;
  1090.     moved := TRUE;
  1091.     repeat
  1092.       dispscore;
  1093.       if makelist(list, currentplayer, mainboard) > 0 then
  1094.         begin
  1095.           moved := TRUE;
  1096.           k := getmove(list, playertype[currentplayer]);
  1097.           makemove(k, currentplayer)
  1098.         end
  1099.       else if moved then
  1100.         moved := FALSE
  1101.       else
  1102.         gameover := TRUE;
  1103.       currentplayer := 1-currentplayer
  1104.     until gameover;
  1105.     declarewinner
  1106.   end; { playgame }
  1107.  
  1108. begin { main program }
  1109.   initgraph;
  1110.   disptitle('R E V E R S I');
  1111.   center('Version 1.4.1', 2);
  1112.   initrev;
  1113.   dispgrid;
  1114.   buildsquare;
  1115.   repeat
  1116.     playgame;
  1117.     eraseline(24);
  1118.     GotoXY(1,24);
  1119.     write('Play again? (Y/N): ');
  1120.     ch := getkey(ch, ['Y', 'N'], TRUE);
  1121.     eraseline(24)
  1122.   until ch = 'N';
  1123.   Textmode;
  1124.   ClrScr
  1125. end { reversi } .
  1126.